;; -*- Mode: LFE; -*-
;; Code from Paradigms of Artificial Intelligence Programming
;; Copyright (c) 1991 Peter Norvig, Common Lisp version
;; Copyright (c) 2008-2020 Robert Virding

;; File    : gps1.lisp
;; Author  : Peter Norvig, Robert Virding
;; Purpose : Demonstrate the General Problem Solver from PAIP in LFE.

;; This files was converted from the PAIP Common Lisp book source cdoe to LFE
;; by Robert Virding. This example is the first (naive) GPS implementation
;; given in the book.
;;
;; Here is some example usage for a successful run:
;;
;; $ ./bin/lfe
;; 
;; lfe> (slurp "examples/gps1.lfe")
;; #(ok gps1)
;; lfe> (gps '(son-at-home car-needs-battery have-money have-phone-book)
;;        '(son-at-school)
;;        (school-ops))
;; executing 'look-up-number'
;; executing 'telephone-shop'
;; executing 'tell-shop-problem'
;; executing 'give-shop-money'
;; executing 'shop-installs-battery'
;; executing 'drive-son-to-school'
;; solved
;; lfe>
;;
;; Here is an unsuccessful run:
;;
;; lfe> (gps '(son-at-home car-needs-battery have-money have-phone-book)
;;        '(son-at-school have-money)
;;        (school-ops))
;; executing 'look-up-number'
;; executing 'telephone-shop'
;; executing 'tell-shop-problem'
;; executing 'give-shop-money'
;; executing 'shop-installs-battery'
;; executing 'drive-son-to-school'
;; false
;; lfe>
;;
;; And a trivial run (for Saturdays!):
;;
;; lfe> (gps '(son-at-home) '(son-at-home) (school-ops))
;; solved
;;
(include-lib "lfe/include/scm.lfe")

;; Define macros for global variable access. This is a hack and very naughty!
(defsyntax defvar
  ([name val] (let ((v val)) (put 'name v) v)))

(defsyntax setvar
  ([name val] (let ((v val)) (put 'name v) v)))

(defsyntax getvar
  ([name] (get 'name)))

;; Module definition.
(defmodule gps1
  (export 
   (gps 2) 
   (gps 3)
   (school-ops 0))
  (import 
   (from lists 
         (member 2) 
         (all 2) 
         (any 2))
   ;; Rename lists functions to be more CL like.
   (rename lists 
           ((all 2) every) 
           ((any 2) some) 
           ((filter 2) find-all))))

;; An operation.
(defrecord op
  action preconds add-list del-list)

;; General Problem Solver: achieve all goals using *ops*.
(defun gps (state goals ops)
  ;; Set global variables
  (defvar *state* state)    ;The current state: a list of conditions.
  (defvar *ops* ops)        ;A list of available operators.
  (if (every (fun achieve 1) goals) 'solved))

(defun gps (state goals)
  ;; Set global variables, but use existing *ops*
  (defvar *state* state)    ;The current state: a list of conditions.
  (if (every (fun achieve 1) goals) 'solved))

;; A goal is achieved if it already holds or if there is an
;; appropriate op for it that is applicable."
(defun achieve (goal)
  (orelse (member goal (getvar *state*))
          (some (fun apply-op 1)
                (find-all (lambda (op) (appropriate-p goal op))
                          (getvar *ops*)))))

;; An op is appropriate to a goal if it is in its add list.
(defun appropriate-p (goal op)
  (member goal (op-add-list op)))

;; Print a message and update *state* if op is applicable.
(defun apply-op (op)
  (if (every (fun achieve 1) (op-preconds op))
    (progn
      (io:fwrite "executing ~p\n" (list (op-action op)))
      (setvar *state* (set-difference (getvar *state*) (op-del-list op)))
      (setvar *state* (union (getvar *state*) (op-add-list op)))
      'true)))

;; Define the set functions to work on list, a listsets module really.
(defun set-difference
  ([(cons e es) s2]
   (if (member e s2)
     (set-difference es s2)
     (cons e (set-difference es s2))))
  ([() s2] ()))

(defun union
  ([(cons e es) s2]
   (if (member e s2) (union es s2) (cons e (union es s2))))
  ([() s2] ()))

;; Define a list of operations to use with GPS.
(defun school-ops ()
  (list
   (make-op action 'drive-son-to-school
            preconds '(son-at-home car-works)
            add-list '(son-at-school)
            del-list '(son-at-home))
   (make-op action 'shop-installs-battery
            preconds '(car-needs-battery shop-knows-problem shop-has-money)
            add-list '(car-works)
            del-list ())
   (make-op action 'tell-shop-problem
            preconds '(in-communication-with-shop)
            add-list '(shop-knows-problem)
            del-list ())
   (make-op action 'telephone-shop
            preconds '(know-phone-number)
            add-list '(in-communication-with-shop)
            del-list ())
   (make-op action 'look-up-number
            preconds '(have-phone-book)
            add-list '(know-phone-number)
            del-list ())
   (make-op action 'give-shop-money
            preconds '(have-money)
            add-list '(shop-has-money)
            del-list '(have-money))))
